home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / product.arc / ACAD2.LSP < prev    next >
Encoding:
Text File  |  1986-11-07  |  10.9 KB  |  330 lines
  1. ;These are the functions in ACAD2.LSP:
  2. ;   1.  Rectangle at any angle (raa) 
  3. ;   2.  Spiral (spiral) 
  4. ;   3.  Clean Atomlist/Garbage Collection (kln) 
  5. ;   4.  Erase Last (EL) 
  6. ;   5.  Erase Window (EW) 
  7. ;   6.  Zoom Window (ZW) 
  8. ;   7.  Zoom Previous (ZP) 
  9. ;   8.  Draw Line (L) 
  10. ;   9.  Square at any angle (sq) 
  11. ;  10.  Convert Civil Units (conv) 
  12. ;  11.  Absolute scale of blocks (ascale) 
  13. ;  12.  Angled sequential numbers (an) 
  14. ;  13.  Slot (slot) 
  15. ;  14.  Change text style global (cs) 
  16. ;  15.  Extend (exd) 
  17. ;  16.  Step and Repeat (sr) 
  18. ;  17.  Flange (flange) 
  19. ;  18.  Parrallelogram  (paa) 
  20.  
  21. ;1.  Draws a rectangle at any angle. 
  22. (Defun C:Raa (/ P1 P2 P3 P4 A B) 
  23.        (Setvar "Cmdecho" 0) 
  24.        (Setq A (Getvar "Snapang")) 
  25.        (Setq B (Getvar "Orthomode")) 
  26.        (Setq P1 (Getpoint "\nFrom point: ")) 
  27.        (Setq P2 (Getpoint P1 "\nTo point: ")) 
  28.        (Command "Line" P1 P2 "") 
  29.        (Setvar "Snapang" (Angle P1 P2)) 
  30.        (Setvar "Orthomode" 1) 
  31.        (Setq P3 (Getpoint P2 "\nTo point: ")) 
  32.        (Setq P4 (Polar P3 (Angle P2 P1) (Distance P2 P1))) 
  33.        (Command "Line" P2 P3 P4 P1 "") 
  34.        (Setvar "Snapang" A) 
  35.        (Setvar "Orthomode" B) 
  36. ) 
  37.  
  38. ;2.  Function for spiral. 
  39. (Defun Cspiral (NTIMES BPOINT CFAC LPPASS / ANG DIST TP AINC DINC
  40. CIRCLE BS CS) 
  41.        (Setq CS (Getvar "Cmdecho")) 
  42.        (Setq BS (Getvar "Blipmode")) 
  43.        (Setvar "Blipmode" 0) 
  44.        (Setvar "Cmdecho" 0) 
  45.        (Setq CIRCLE (* 3.141596235 2)) 
  46.        (Setq AINC (/ CIRCLE LPPASS)) 
  47.        (Setq DINC (/ CFAC LPPASS)) 
  48.        (Setq ANG 0.0) 
  49.        (Setq DIST 0.0) 
  50.        (Command "Pline" BPOINT) 
  51.        (Repeat NTIMES 
  52.                (Repeat LPPASS 
  53.                        (Setq TP (Polar BPOINT (Setq ANG (+ ANG
  54. AINC)) 
  55.                                 (Setq DIST (+ DIST DINC)))) 
  56.                        (Command TP) 
  57.                ) 
  58.        ) 
  59.        (Command) 
  60.        (Setvar "Blipmode" BS) 
  61.        (Setvar "Cmdecho" CS) 
  62.         nil 
  63. ) 
  64.  
  65. ;   Interactive spiral generation. 
  66. (Defun C:Spiral (/ NT BP CF LP) 
  67.        (Prompt "\nCenter point: ") 
  68.        (Setq BP (Getpoint)) 
  69.        (Prompt "\nNumber of rotations: ") 
  70.        (Setq NT (Getint)) 
  71.        (Prompt "\nGrowth per rotation: ") 
  72.        (Setq CF (Getdist BP)) 
  73.        (Prompt "\nPoints per rotation: ") 
  74.        (Setq LP (Getint)) 
  75.        (Cond ((null LP) (Setq LP 30))) 
  76.        (Cspiral NT BP CF LP) 
  77. ) 
  78.  
  79. ;3.  Cleans the atomlist, freeing node space 
  80. ;    and does a garbage collection. 
  81. (Defun C:Kln () 
  82.        (Setq ATOMLIST (Member 'INTERS ATOMLIST)) 
  83.        (GC) 
  84. ) 
  85.  
  86. ;4.  Types "EL" to erase the last object. 
  87. (Defun C:EL () 
  88.        (Command "Erase" "L" "") 
  89. ) 
  90.  
  91. ;5.  Types "EW" to erase a window. 
  92. (Defun C:EW () 
  93.        (Command "Erase" "W") 
  94. ) 
  95.  
  96. ;6.  Types "ZW" to zoom a window. 
  97. (Defun C:ZW () 
  98.        (Command "Zoom" "W") 
  99. ) 
  100.  
  101. ;7.  Types "ZP" to zoom previous. 
  102. (Defun C:ZP () 
  103.        (Command "Zoom" "P") 
  104. ) 
  105.  
  106. ;8.  Types "L" to draw a line. 
  107. (Defun C:L () 
  108.        (Command "Line") 
  109. ) 
  110.  
  111. :9.  Draws a a square at any angle. 
  112. (Defun C:Sq (/ P1 P2 P3 P4) 
  113.        (Setq P1 (Getpoint "\nLower left corner: ")) 
  114.        (Setq A (Getdist P1 "\nLength of one side: ")) 
  115.        (Setq P2 (Polar P1 0.0 A)) 
  116.        (Setq P3 (Polar P2 (/ Pi 2.0) A)) 
  117.        (Setq P4 (Polar P3 Pi A)) 
  118.        (Command "Line" P1 P2 P3 P4 "C") 
  119. ) 
  120.  
  121. ;10.  Converts civil units (decimal feet)  
  122. ;     to architectural units (feet & inches). 
  123. (Defun C:Conv (/ A B C D E F G H) 
  124.        (Setq A (Getreal "Enter number to convert to feet and
  125. inches: ")) 
  126.        (Setq B (Fix A)) 
  127.        (Setq C (- A B)) 
  128.        (Setq C (* C 12)) 
  129.        (Setq D (Fix C)) 
  130.        (Setq C (- C D)) 
  131.        (If (>= C 0.9688) (Setq E (Chr 34))) 
  132.        (If (>= C 0.9688) (Setq D (+ D 1))) 
  133.        (If (>= D 12) (Setq B (+ B 1))) 
  134.        (If (>= D 12) (Setq D 0)) 
  135.        (If (< C 0.9688) (Setq E (Strcat "15/16" (Chr 34)))) 
  136.        (If (< C 0.9063) (Setq E (Strcat "7/8" (Chr 34)))) 
  137.        (If (< C 0.8438) (Setq E (Strcat "13/16" (Chr 34)))) 
  138.        (If (< C 0.7813) (Setq E (Strcat "3/4" (Chr 34)))) 
  139.        (If (< C 0.7188) (Setq E (Strcat "11/16" (Chr 34)))) 
  140.        (If (< C 0.6563) (Setq E (Strcat "5/8" (Chr 34)))) 
  141.        (If (< C 0.5938) (Setq E (Strcat "9/16" (Chr 34)))) 
  142.        (If (< C 0.5313) (Setq E (Strcat "1/2" (Chr 34)))) 
  143.        (If (< C 0.4688) (Setq E (Strcat "7/16" (Chr 34)))) 
  144.        (If (< C 0.4063) (Setq E (Strcat "3/8" (Chr 34)))) 
  145.        (If (< C 0.3438) (Setq E (Strcat "5/16" (Chr 34)))) 
  146.        (If (< C 0.2813) (Setq E (Strcat "1/4" (Chr 34)))) 
  147.        (If (< C 0.2188) (Setq E (Strcat "3/16" (Chr 34)))) 
  148.        (If (< C 0.1563) (Setq E (Strcat "1/8" (Chr 34)))) 
  149.        (If (< C 0.0938) (Setq E (Strcat "1/16" (Chr 34)))) 
  150.        (If (< C 0.0313) (Setq E (Chr 34))) 
  151.        (Setq F (itoa B)) 
  152.        (Setq G (itoa D)) 
  153.        (Setq H "Conversion from decimal to feet and inches is: ")
  154.  
  155.        (Strcat H F (chr 39) (chr 45) G (chr 32) E (chr 32) (chr
  156. 32)) 
  157. ) 
  158.  
  159. ;11.  Absolute scale - allows easy rescaling of blocks 
  160. (Defun C:Ascale (/ A B C D E F G H) 
  161.        (Setq A (Ssget)) 
  162.        (Setq B (Sslength A)) 
  163.        (Setq C (Getreal "\nEnter new scale: ")) 
  164.        (While (> B 0) 
  165.               (Setq B (1- B)) 
  166.               (Setq D (Ssname A B)) 
  167.               (Setq D (Entget D)) 
  168.               (Setq E (Assoc 41 D)) 
  169.               (Setq F (Assoc 42 D)) 
  170.               (Setq G (Cons 41 C)) 
  171.               (Setq H (Cons 42 C)) 
  172.               (Setq D (Subst G E D)) 
  173.               (Entmod (Setq D (Subst H F D))) 
  174.        ) 
  175. ) 
  176.  
  177. ;12.  Angled numbers. 
  178. (Defun C:An (/ P1 A1 A B C D E F G) 
  179.        (Setvar "Cmdecho" 0) 
  180.        (Setq G (Getvar "Blipmode")) 
  181.        (Setvar "Blipmode" 0) 
  182.        (Setq A (Getint "\nNumber to start with: ")) 
  183.        (Setq B (Getint "\nNumber to end with: ")) 
  184.        (Setq P1 (Getpoint "\nStarting point: ")) 
  185.        (Setq C (Getdist P1 "\nDistance between numbers: ")) 
  186.        (Setq A1 (Getangle P1 "\nAngle to run numbers: ")) 
  187.        (Setq D (Getdist P1 "\nText height: ")) 
  188.        (If (> A B) 
  189.            (Setq E -1) 
  190.            (Setq E 1) 
  191.        ) 
  192.        (Repeat (+ 1 (Abs (- A B))) 
  193.                (Setq F (Itoa A)) 
  194.                (Command "Text" "C" P1 D 0 F) 
  195.                (Setq A (+ A E)) 
  196.                (Setq P1 (Polar P1 A1 C)) 
  197.        ) 
  198.        (Setvar "Blipmode" G) 
  199. ) 
  200.  
  201. ;13.  Draws a slot. 
  202. (Defun C:Slot (/ P1 A B C) 
  203.        (Setvar "Cmdecho" 0) 
  204.        (Setq P1 (Getpoint "\nInsertion point of slot: ")) 
  205.        (Setq A (Getdist P1 "\nRadius: ")) 
  206.        (Setq B (Getdist P1 "\nLength: ")) 
  207.        (Setq C (Getangle P1 "\nAngle: ")) 
  208.        (Command "Arc" "C" P1 (Polar P1 (+ (/ Pi 2) C) A) "A"
  209. "180") 
  210.        (Command "Line" "" (Polar (Getvar "Lastpoint") A B) "") 
  211.        (Command "Arc" "" (Polar (Getvar "Lastpoint") (+ (/ Pi 2)
  212. C) (* 2 A))) 
  213.        (Command "Line" "" (Polar (Getvar "Lastpoint") (+ Pi C) B)
  214. "") 
  215. ) 
  216.  
  217. ;14.  Changes text styles 
  218. (Defun C:Cs (/ A B C D E) 
  219.        (Setvar "Cmdecho" 0) 
  220.        (Setq A (Getstring "\nOld Style Name: ")) 
  221.        (Setq B (Getstring "\nNew Style Name: ")) 
  222.        (Setq C (Entnext)) 
  223.        (While (Boundp 'C) 
  224.               (Setq D (Entget C)) 
  225.               (If (= (Cdr (Assoc 0 D)) "TEXT") 
  226.                   (Progn 
  227.                        (If (= (Cdr (Assoc 7 D)) A) 
  228.                            (Progn 
  229.                                 (Setq E (Assoc 7 D)) 
  230.                                 (Setq D (Subst (Cons 7 B) E D)) 
  231.                                 (Entmod D) 
  232.                            ) 
  233.                        ) 
  234.                   ) 
  235.               ) 
  236.               (Setq C (Entnext C)) 
  237.        ) 
  238. ) 
  239.  
  240. ;15. Extends a line to a given distance
  241. (Defun C:exd (/ P1 P2 A B C D E) 
  242.        (Setvar "Cmdecho" 0) 
  243.        (Setq A (Getvar "Gridmode")) 
  244.        (Setq B (Getvar "Snapmode")) 
  245.        (Setq C (Getvar "Snapang")) 
  246.        (Setq E (Getvar "Orthomode")) 
  247.        (Setvar "Orthomode" 1) 
  248.        (Setq P2 (Osnap (Setq P1 (Osnap (Getpoint 
  249.                  "Touch line to change: ")"End"))"Mid")) 
  250.        (Setvar "Gridmode" 0) 
  251.        (Setvar "Snapmode" 0) 
  252.        (Setvar "Snapang" (Angle P2 P1)) 
  253.        (Setq D (Getdist P1 "How far: ")) 
  254.        (Command "Change" P1 "" (Polar P1 (Angle P2 P1) D)) 
  255.        (Setvar "Gridmode" A) (Setvar "Snapmode" B) 
  256.        (Setvar "Snapang" C)) 
  257.  
  258. ;16.  Step and Repeat 
  259. (Defun C:SR (/ P1 P2 A1 A B C D E BT CT) 
  260.        (Setvar "Cmdecho" 0) 
  261.        (Setq B (If (null B) "" B)) 
  262.        (Setq C (If (null C) 1.0 C)) 
  263.        (Setq P1 (Getpoint "\nFirst point: ")) 
  264.        (Setq P2 (Getpoint "\nSecond point: ")) 
  265.        (Setq A1 (Angle P1 P2)) 
  266.        (Setq A (Getint "\nNumber of items: ")) 
  267.        (Prompt "\nBlock name <") (Prompt B) 
  268.        (Setq BT (Getstring ">: ")) 
  269.        (Setq B (If (null BT) B BT)) 
  270.        (Prompt "\nScale factor <") 
  271.        (Prompt (Rtos C (Getvar "Lunits") (Getvar "Luprec"))) 
  272.        (Setq CT (Getreal ">: ")) 
  273.        (Setq C (If (null CT) C CT)) 
  274.        (Setq D (Getstring "\nRotate item <N>: ")) 
  275.        (Setq D (If (= D "y") "Y" "N")) 
  276.        (If (= D "Y") 
  277.            (Setq D (* (/ 180 Pi) A1)) 
  278.            (Setq D 0) 
  279.        ) 
  280.        (Setq E (Distance P1 P2)) 
  281.        (Setq E (/ E (- A 1))) 
  282.        (Repeat A 
  283.                (Command "Insert" B P1 C "" D) 
  284.                (Setq P1 (Polar P1 A1 E)) 
  285.        ) 
  286. ) 
  287.  
  288. ;17.  Draws a flange 
  289. (Defun C:Flange () 
  290.        (Setvar "Cmdecho" 0) 
  291.        (Setq OR 0) (Setq IR 0) (Setq BC 0) 
  292.        (Setq P1 (Getpoint "\nEnter center of flange: ")) 
  293.        (Setq OR (Getdist P1 "\nOutside radius: ")) 
  294.        (Command "Circle" P1 OR) 
  295.        (Setq IR (Getdist P1 "\nInside radius: ")) 
  296.        (While (> IR OR) 
  297.        (Prompt "\nInside radius larger than outside: ") 
  298.        (Setq IR (Getdist P1 "\nInside radius: "))) 
  299.        (Command "Circle" P1 IR) 
  300.        (Setq bad 1) 
  301.        (While bad 
  302.        (Setq A nil) (Setq B nil) 
  303.        (Setq BC (Getdist P1 "Bolt circle radius: ")) 
  304.        (IF (> BC OR)  
  305.        (Prompt "\nBolt circle larger than O.D.: ") 
  306.        (setq a t)) 
  307.        (If (< BC IR)  
  308.        (Prompt "\nBolt circle smaller than I.D.: ") 
  309.        (Setq b t)) 
  310.        (if (and a b) (setq bad nil))) 
  311.        (Command "Circle" P1 BC) 
  312.        (Setq SH (Getreal "Bolt hole diameter: ")) 
  313.        (Setq NHI (Getint "Number of bolt holes: ")) 
  314.        (Setq NH (Float NHI)) 
  315.        (Setq SA (Getangle P1 
  316.        "Starting angle of first hole: ")) 
  317.        (Command "Circle" (Polar P1 SA BC) "D" SH) 
  318.        (Command "Array" "L" "" "C" P1 (/ 360 NH) NHI "")) 
  319.  
  320. ;18. Parrallelogram 
  321. (Defun C:PAA () 
  322.   (Setvar "Cmdecho" 0) 
  323.   (Setq P1 (Getpoint "\nFrom point: ")) 
  324.   (Setq P2 (Getpoint P1 "\nTo point: ")) 
  325.   (Command "Line" P1 P2 "") 
  326.   (Setq P3(Getpoint P2 "To point: ")) 
  327.   (Setq P4 (Polar P3 (Angle P2 P1) (Distance P2 P1))) 
  328.   (Command "Line" P2 P3 P4 P1 "") 
  329. ) 
  330.